home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / compstate.em < prev    next >
Lisp/Scheme  |  1993-02-02  |  7KB  |  259 lines
  1. ;; Eulisp Module
  2. ;; Author: pete broadbery
  3. ;; File: comp-state.em
  4. ;; Date: 3/sep/1991
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;; structure describing the current state of the compiler
  9. ;;
  10.  
  11. (defmodule compstate
  12.   (standard0
  13.    list-fns
  14.    scan-args
  15.    
  16.    stream
  17.    abs-syntx
  18.    props
  19.  
  20. ;;   stop
  21.    )
  22.   ()
  23.   
  24.   (defcondition Compiler-State-Error ())
  25.  
  26.   ;; stack model
  27.   (defstruct stack ()
  28.     ((state initarg initstate
  29.         initform ()
  30.         reader stack-state))
  31.     constructor (make-stack)
  32.     constructor (m-s-internal initstate)
  33.     constructor (copy-stack stack))
  34.  
  35.   (defmethod generic-prin ((x stack) stream)
  36.     (format stream "#S<~a>" (stack-state x)))
  37.  
  38.   (defstruct stack-val ()
  39.     ((names accessor stack-val-names))
  40.     constructor make-stack-val)
  41.   
  42.   (defmethod generic-prin ((x stack-val) stream)
  43.     (prin "#<?>" stream))
  44.  
  45.   (export make-stack-val)
  46.  
  47.     (defun stack-top (stack)
  48.     (if (null (stack-state stack))
  49.     (error "Empty stack in Stack-top" Compiler-State-Error)
  50.       (car (stack-state stack))))
  51.  
  52.   (defun stack-pop (stack count)
  53.     (if (null (stack-state stack))
  54.     (error "Empty stack in Stack-pop" Compiler-State-Error)
  55.       (m-s-internal (nthcdr count (stack-state stack)))))
  56.   
  57.   (defun stack-slide (stack low keep)
  58.     (if (< (stack-depth stack) low)
  59.     (m-s-internal nil)
  60.       (m-s-internal (append (copy-n keep (stack-state stack))
  61.                 (nthcdr low (stack-state stack))))))
  62.  
  63.   (defun copy-n (n lst)
  64.     (if (= n 0) ()
  65.       (cons (car lst) (copy-n (- n 1) (cdr lst)))))
  66.  
  67.   (defun stack-push (stack val)
  68.     (m-s-internal (cons val (stack-state stack))))
  69.  
  70.   (defun stack-swap (stack)
  71.     (m-s-internal (cons (cadr (stack-state stack))
  72.             (cons (car (stack-state stack))
  73.                   (cddr (stack-state stack))))))
  74.  
  75.   (defun scanq-stack (stack val)
  76.     (scan-aux (stack-state stack) val 0 eq))
  77.   
  78.   (defun scan-aux (lst val n fn)
  79.     (cond ((null lst)
  80.        (error "Value not on stack" Compiler-State-Error 
  81.           'error-value val))
  82.       ((fn (car lst) val)
  83.        n)
  84.       (t (scan-aux (cdr lst) val (+ n 1) fn))))
  85.  
  86.  
  87.   (defun stack-ref (stack n)
  88.     ;; if the value is over the edge, don't worry.
  89.     (let ((xx (st-ref-aux (stack-state stack) n)))
  90.       (if xx (car xx) nil)))
  91.   
  92.   ((setter setter) stack-ref
  93.    (lambda (stack n val)
  94.      (let ((xx (st-ref-aux (stack-state stack) n)))
  95.        (if (null xx) nil
  96.      ((setter car) xx val)))))
  97.  
  98.   (defun st-ref-aux (lst n)
  99.     (if (null lst) nil
  100.       (if (= n 0) 
  101.       lst
  102.     (st-ref-aux (cdr lst)
  103.             (- n 1)))))
  104.   
  105.   (defun stack-depth (stack)
  106.     (list-length (stack-state stack)))
  107.  
  108.   (export stack make-stack copy-stack stack-top stack-pop
  109.       stack-push scanq-stack stack-ref stack-depth
  110.       stack-slide stack-swap)
  111.  
  112.   ;; Objects stored in the state
  113.  
  114.   ;; note that it may be tricky to calculate the env size
  115.   (defstruct env-object () 
  116.     ((size initarg size accessor env-object-size)
  117.      (content initarg content
  118.           accessor env-object-content)
  119.      (prev initarg prev
  120.        accessor env-object-prev))
  121.     constructor (make-env-object size content prev))
  122.   
  123.   (export make-env-object env-object-size env-object-content env-object-prev)
  124.  
  125.   (defstruct static ()
  126.     ((id initarg id 
  127.      accessor static-id)
  128.      (type initarg type 
  129.        accessor static-id-type)
  130.      (content initarg content
  131.           accessor static-content))
  132.     constructor (make-static id type content))
  133.  
  134.   
  135.   (defconstant mk-new-static-id (mk-counter 0))
  136.  
  137.   ;; We cheat 
  138.   (defun make-static-store ()
  139.     (list (mk-counter 0) ()))
  140.   
  141.   (defun append-statics (s1 s2)
  142.     (fold insert-static (cadr s1) s2))
  143.  
  144.   (defun add-static (val statics)
  145.     (let ((xx (assq val (cadr statics))))
  146.       (if (not (null xx))
  147.       (list xx statics)
  148.     (let ((new (cons val ((car statics)))))
  149.       (list new (list (car statics) 
  150.               (cons new (cadr statics))))))))
  151.  
  152.  
  153.   (defun insert-static (val statics)
  154.     (list (car statics) (cons val statics)))
  155.  
  156.  
  157.   (defun statics-2-list (x)
  158.     (reverse (mapcar car (cadr x))))
  159.  
  160.   (defun static-val-id (x) 
  161.     (cdr x))
  162.  
  163.   (export make-static-store add-static append-statics 
  164.       statics-2-list static-val-id)
  165.  
  166.   ;; Code lists
  167.   
  168.   (defun add-code-vectors (values state)
  169.     (append values (state-code state)))
  170.  
  171.   (defun make-code-list ()
  172.     nil)
  173.  
  174.   (export add-code-vectors make-code-list)
  175.   
  176.   ;; Posh name for assemble...
  177.   ;; 
  178.   
  179.   (defun reify-code-stream (state)
  180.     (convert (state-stream state) pair))
  181.  
  182.   (defun instructions2link-table (stream)
  183.     (instruct-2-links-aux stream ()))
  184.   
  185.   (defun instruct-2-links-aux (stream external-refs )
  186.     nil)
  187.   
  188.   (export reify-code-stream)
  189.   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  190.   ;; The complete compiler state
  191.   
  192.   (defstruct compiler-state ()
  193.     ((stack initform 'no-value
  194.         initarg state-stack
  195.         accessor state-stack)
  196.      (output-stream initform 'no-value
  197.             initarg state-stream
  198.             accessor state-stream)
  199.      (statics initarg state-statics 
  200.           initform 'no-value
  201.           accessor state-statics)
  202.      (code initarg state-code
  203.        initform 'no-value
  204.        accessor state-code))
  205.     constructor (make-compiler-state state-stream state-stack state-statics state-code)
  206.     constructor (modify-compiler-state state . junk))
  207.  
  208.  
  209.   (defmethod generic-prin ((state compiler-state) stream)
  210.     (format stream "#<state: ~a>" (state-stack state)))
  211.  
  212.   (export state-stack state-stream state-statics state-code)
  213.  
  214.   ;; Real hack...
  215.   ;;(defun make-compiler-state (from initargs)
  216.   ;;(initialize-instance (copy from) initargs))
  217.   
  218.   (export make-compiler-state modify-compiler-state)
  219.  
  220.   (defmethod initialize-instance ((x compiler-state) args)
  221.     (let ((new-state (call-next-method)))
  222.       (if (not (eq (car args) 'state))
  223.       new-state
  224.     ;; if we want a copy...
  225.     (let ((old-state (cadr args)))
  226.       (if (eq (state-stream new-state) 'no-value)
  227.           ((setter state-stream) new-state 
  228.            (state-stream old-state))
  229.         nil)
  230.       (if (eq (state-statics new-state) 'no-value)
  231.           ((setter state-statics) new-state
  232.            (state-statics old-state))
  233.         nil)
  234.       (if (eq (state-stack new-state) 'no-value)
  235.           ((setter state-stack) new-state
  236.            (state-stack old-state))
  237.         nil)
  238.       (if (eq (state-code new-state) 'no-value)
  239.           ((setter state-code) new-state
  240.            (state-code old-state))
  241.         nil)
  242.       new-state))))
  243.  
  244.   ;; And before I forget,
  245.   ;; Generating code..
  246.   
  247.   (defun add-instruction (i stream)
  248.     (write-stream stream i))
  249.   
  250.   (defun update-comp-state (state stacker streamer)
  251.     (modify-compiler-state 
  252.      state
  253.      'state-stack (stacker (state-stack state))
  254.      'state-stream (streamer (state-stream state))))
  255.   
  256.   (export add-instruction update-comp-state)
  257.   ;; end module
  258.   )
  259.